home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / c / assignment.c < prev    next >
C/C++ Source or Header  |  1987-06-04  |  12KB  |  557 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.  
  9.     assignment.c
  10.  
  11.     Assignment
  12. */
  13.  
  14. #include "include.h"
  15.  
  16. object Ssetf;
  17.  
  18. object Sget;
  19. object Saref;
  20. object Ssvref;
  21. object Selt;
  22. object Schar;
  23. object Sschar;
  24. object Sfill_pointer;
  25. object Sgethash;
  26. object Scar;
  27. object Scdr;
  28.  
  29. object Spush;
  30. object Spop;
  31. object Sincf;
  32. object Sdecf;
  33.  
  34. object siSstructure_access;
  35. object siSsetf_lambda;
  36. object Svector;
  37. object Slist;
  38.  
  39. object siSclear_compiler_properties;
  40.  
  41. object Swarn;
  42.  
  43. object siVinhibit_macro_special;
  44.  
  45.  
  46. setq(sym, val)
  47. object sym, val;
  48. {
  49.     object vd;
  50.     enum stype type;
  51.  
  52.     if(type_of(sym) != t_symbol)
  53.         not_a_symbol(sym);
  54.     type = (enum stype)sym->s.s_stype;
  55.     if (type == stp_constant)
  56.         FEinvalid_variable("Cannot assign to the constant ~S.", sym);
  57.     else if(type == stp_special)
  58.         sym->s.s_dbind = val;
  59.     else {
  60.         vd = lex_var_sch(sym);
  61.         if(MMnull(vd) || endp(MMcdr(vd)))
  62.             sym->s.s_dbind = val;
  63.         else
  64.             MMcadr(vd) = val;
  65.     }
  66. }
  67.  
  68. Fsetq(form)
  69. object form;
  70. {
  71.     if (endp(form)) {
  72.         vs_base = vs_top;
  73.         vs_push(Cnil);
  74.     } else {
  75.         object *top = vs_top;
  76.         do {
  77.             vs_top = top;
  78.             if (endp(MMcdr(form)))
  79.             FEinvalid_form("No value for ~S.", form->c.c_car);
  80.             eval(MMcadr(form));
  81.             setq(MMcar(form), vs_base[0]);
  82.             form = MMcddr(form);
  83.         } while (!endp(form));
  84.         vs_top = vs_base+1;
  85.     }
  86. }
  87.  
  88. Fpsetq(arg)
  89. object arg;
  90. {
  91.     object *old_top = vs_top;
  92.     object *top;
  93.     object argsv = arg;
  94.     for (top = old_top;  !endp(arg);  arg = MMcddr(arg), top++) {
  95.         if(endp(MMcdr(arg)))
  96.             FEinvalid_form("No value for ~S.", arg->c.c_car);
  97.         eval(MMcadr(arg));
  98.         top[0] = vs_base[0];
  99.         vs_top = top + 1;
  100.     }
  101.     for (arg = argsv, top = old_top; !endp(arg); arg = MMcddr(arg), top++)
  102.         setq(MMcar(arg),top[0]);
  103.     vs_base = vs_top = old_top;
  104.     vs_push(Cnil);
  105. }
  106.  
  107. Lset()
  108. {
  109.     check_arg(2);
  110.     if (type_of(vs_base[0]) != t_symbol)
  111.         not_a_symbol(vs_base[0]);
  112.     if ((enum stype)vs_base[0]->s.s_stype == stp_constant)
  113.         FEinvalid_variable("Cannot assign to the constant ~S.",
  114.                    vs_base[0]);
  115.     vs_base[0]->s.s_dbind = vs_base[1];
  116.     vs_base++;
  117. }
  118.  
  119. siLfset()
  120. {
  121.     check_arg(2);
  122.     if (type_of(vs_base[0]) != t_symbol)
  123.         not_a_symbol(vs_base[0]);
  124.     if (vs_base[0]->s.s_sfdef != NOT_SPECIAL) {
  125.         if (vs_base[0]->s.s_mflag) {
  126.             if (symbol_value(siVinhibit_macro_special) != Cnil)
  127.                 vs_base[0]->s.s_sfdef = NOT_SPECIAL;
  128.         } else if (symbol_value(siVinhibit_macro_special) != Cnil)
  129.             FEerror("~S, a special form, cannot be redefined.",
  130.                 1, vs_base[0]);
  131.     }
  132.     clear_compiler_properties(vs_base[0]);
  133.     if (vs_base[0]->s.s_hpack == lisp_package &&
  134.         vs_base[0]->s.s_gfdef != OBJNULL && initflag) {
  135.         vs_push(make_simple_string(
  136.             "~S is being redefined."));
  137.         ifuncall2(Swarn, vs_head, vs_base[0]);
  138.         vs_pop;
  139.     }
  140.     if (type_of(vs_base[1]) == t_cfun ||
  141.         type_of(vs_base[1]) == t_cclosure) {
  142.         vs_base[0]->s.s_gfdef = vs_base[1];
  143.         vs_base[0]->s.s_mflag = FALSE;
  144.     } else if (car(vs_base[1]) == Sspecial)
  145.         FEerror("Cannot define a special form.", 0);
  146.     else if (vs_base[1]->c.c_car == Smacro) {
  147.         vs_base[0]->s.s_gfdef = vs_base[1]->c.c_cdr;
  148.         vs_base[0]->s.s_mflag = TRUE;
  149.     } else {
  150.         vs_base[0]->s.s_gfdef = vs_base[1];
  151.         vs_base[0]->s.s_mflag = FALSE;
  152.     }
  153.     vs_base++;
  154. }
  155.  
  156. Fmultiple_value_setq(form)
  157. object form;
  158. {
  159.     object vars;
  160.     int n, i;
  161.  
  162.     if (endp(form) || endp(form->c.c_cdr) ||
  163.         !endp(form->c.c_cdr->c.c_cdr))
  164.         FEinvalid_form("~S is an illegal argument to MULTIPLE-VALUE-SETQ",
  165.                form);
  166.     vars = form->c.c_car;
  167.     vs_push(vars);
  168.     eval(form->c.c_cdr->c.c_car);
  169.     n = vs_top - vs_base;
  170.     for (i = 0;  !endp(vars);  i++, vars = vars->c.c_cdr)
  171.         if (i < n)
  172.             setq(vars->c.c_car, vs_base[i]);
  173.         else
  174.             setq(vars->c.c_car, Cnil);
  175.     vs_top = vs_base+1;
  176. }
  177.  
  178. Lmakunbound()
  179. {
  180.     check_arg(1);
  181.     if (type_of(vs_base[0]) != t_symbol)
  182.         not_a_symbol(vs_base[0]);
  183.     if ((enum stype)vs_base[0]->s.s_stype == stp_constant)
  184.         FEinvalid_variable("Cannot unbind the constant ~S.",
  185.                    vs_base[0]);
  186.     vs_base[0]->s.s_dbind = OBJNULL;
  187. }
  188.     
  189. Lfmakunbound()
  190. {
  191.     check_arg(1);
  192.     if(type_of(vs_base[0]) != t_symbol)
  193.         not_a_symbol(vs_base[0]);
  194.     if (vs_base[0]->s.s_sfdef != NOT_SPECIAL) {
  195.         if (vs_base[0]->s.s_mflag) {
  196.             if (symbol_value(siVinhibit_macro_special) != Cnil)
  197.                 vs_base[0]->s.s_sfdef = NOT_SPECIAL;
  198.         } else if (symbol_value(siVinhibit_macro_special) != Cnil)
  199.             FEerror("~S, a special form, cannot be redefined.",
  200.                 1, vs_base[0]);
  201.     }
  202.     clear_compiler_properties(vs_base[0]);
  203.     if (vs_base[0]->s.s_hpack == lisp_package &&
  204.         vs_base[0]->s.s_gfdef != OBJNULL && initflag) {
  205.         vs_push(make_simple_string(
  206.             "~S is being redefined."));
  207.         ifuncall2(Swarn, vs_head, vs_base[0]);
  208.         vs_pop;
  209.     }
  210.     vs_base[0]->s.s_gfdef = OBJNULL;
  211.     vs_base[0]->s.s_mflag = FALSE;
  212. }
  213.  
  214. Fsetf(form)
  215. object form;
  216. {
  217.     if (endp(form)) {
  218.         vs_base = vs_top;
  219.         vs_push(Cnil);
  220.     } else {
  221.         object *top = vs_top;
  222.         do {
  223.             vs_top = top;
  224.             if (endp(MMcdr(form)))
  225.             FEinvalid_form("No value for ~S.", form->c.c_car);
  226.             setf(MMcar(form), MMcadr(form));
  227.             form = MMcddr(form);
  228.         } while (!endp(form));
  229.         vs_top = vs_base+1;
  230.     }
  231. }
  232.  
  233. #define    eval_push(form)  \
  234. {  \
  235.     object *old_top = vs_top;  \
  236.   \
  237.     eval(form);  \
  238.     *old_top = vs_base[0];  \
  239.     vs_top = old_top + 1;  \
  240. }
  241.  
  242. setf(place, form)
  243. object place, form;
  244. {
  245.     object fun;
  246.     object *vs = vs_top;
  247.     int (*f)();
  248.     object args;
  249.     object x;
  250.     int i;
  251.     extern siLaset();
  252.     extern siLsvset();
  253.     extern siLelt_set();
  254.     extern siLchar_set();
  255.     extern siLfill_pointer_set();
  256.     extern siLhash_set();
  257.  
  258.     if (type_of(place) != t_cons) {
  259.         eval(form);
  260.         setq(place, vs_base[0]);
  261.         return;
  262.     }
  263.     fun = place->c.c_car;
  264.     if (type_of(fun) != t_symbol)
  265.         goto OTHERWISE;
  266.     args = place->c.c_cdr;
  267.     if (fun == Sget) {
  268.         eval_push(car(args));
  269.         eval_push(form);
  270.         eval_push(car(args->c.c_cdr));
  271.         vs_base = vs;
  272.         siLputprop();
  273.         return;
  274.     }
  275.     if (fun == Saref) { f = siLaset; goto EVAL; }
  276.     if (fun == Ssvref) { f = siLsvset; goto EVAL; }
  277.     if (fun == Selt) { f = siLelt_set; goto EVAL; }
  278.     if (fun == Schar) { f = siLchar_set; goto EVAL; }
  279.     if (fun == Sschar) { f = siLchar_set; goto EVAL; }
  280.     if (fun == Sfill_pointer) { f = siLfill_pointer_set; goto EVAL; }
  281.     if (fun == Sgethash) { f = siLhash_set; goto EVAL; }
  282.     if (fun == Scar) {
  283.         eval_push(args->c.c_car);
  284.         eval(form);
  285.         if (type_of(*vs) != t_cons)
  286.             FEerror("~S is not a cons.", 1, *vs);
  287.         (*vs)->c.c_car = vs_base[0];
  288.         return;
  289.     }
  290.     if (fun == Scdr) {
  291.         eval_push(args->c.c_car);
  292.         eval(form);
  293.         if (type_of(*vs) != t_cons)
  294.             FEerror("~S is not a cons.", 1, *vs);
  295.         (*vs)->c.c_cdr = vs_base[0];
  296.         return;
  297.     }
  298.     x = getf(fun->s.s_plist, siSstructure_access, Cnil);
  299.     if (x == Cnil || type_of(x) != t_cons)
  300.         goto OTHERWISE;
  301.     if (getf(fun->s.s_plist, siSsetf_lambda, Cnil) == Cnil)
  302.         goto OTHERWISE;
  303.     if (type_of(x->c.c_cdr) != t_fixnum)
  304.         goto OTHERWISE;
  305.     i = fix(x->c.c_cdr);
  306. /*
  307.     if (i < 0)
  308.         goto OTHERWISE;
  309. */
  310.     x = x->c.c_car;
  311.     if (x == Svector) {
  312.         eval_push(args->c.c_car);
  313.         x = *vs;
  314.         if (type_of(x) != t_vector || i >= x->v.v_fillp)
  315.             goto OTHERWISE;
  316.         eval(form);
  317.         x->v.v_self[i] = vs_base[0];
  318.     } else if (x == Slist) {
  319.         eval_push(args->c.c_car);
  320.         for (x = *vs;  i > 0;  --i)
  321.             x = cdr(x);
  322.         if (type_of(x) != t_cons)
  323.             goto OTHERWISE;
  324.         eval(form);
  325.         x->c.c_car = vs_base[0];
  326.     } else {
  327.         eval_push(args->c.c_car);
  328.         eval(form);
  329.         structure_set(*vs, x, i, vs_base[0]);
  330.     }
  331.     return;
  332.  
  333. EVAL:
  334.     for (;  !endp(args);  args = args->c.c_cdr) {
  335.         eval_push(args->c.c_car);
  336.     }
  337.     eval_push(form);
  338.     vs_base = vs;
  339.     (*f)();
  340.     return;
  341.  
  342. OTHERWISE:
  343.     vs_base = vs_top;
  344.     vs_push(Ssetf);
  345.     vs_push(place);
  346.     vs_push(form);
  347.     vs_push(Cnil);
  348.     stack_cons();
  349.     stack_cons();
  350.     stack_cons();
  351. /***/
  352.     vs_push(Cnil);
  353. /***/
  354.     if (!Ssetf->s.s_mflag || Ssetf->s.s_gfdef == OBJNULL)
  355.         FEerror("Where is SETF?", 0);
  356.     funcall(Ssetf->s.s_gfdef);
  357.     eval(vs_base[0]);
  358. }
  359.  
  360. Fpush(form)
  361. object form;
  362. {
  363.     object var;
  364.  
  365.     if (endp(form) || endp(MMcdr(form)))
  366.         FEtoo_few_argumentsF(form);
  367.     if (!endp(MMcddr(form)))
  368.         FEtoo_many_argumentsF(form);
  369.     var = MMcadr(form);
  370.     if (type_of(var) != t_cons) {
  371.         eval(MMcar(form));
  372.         form = vs_base[0];
  373.         eval(var);
  374.         vs_base[0] = MMcons(form, vs_base[0]);
  375.         setq(var, vs_base[0]);
  376.         return;
  377.     }
  378.     vs_base = vs_top;
  379.     vs_push(Spush);
  380.     vs_push(form);
  381.     stack_cons();
  382. /***/
  383.     vs_push(Cnil);
  384. /***/
  385.     if (!Spush->s.s_mflag || Spush->s.s_gfdef == OBJNULL)
  386.         FEerror("Where is PUSH?", 0);
  387.     funcall(Spush->s.s_gfdef);
  388.     eval(vs_base[0]);
  389. }
  390.  
  391. Fpop(form)
  392. object form;
  393. {
  394.     object var;
  395.  
  396.     if (endp(form))
  397.         FEtoo_few_argumentsF(form);
  398.     if (!endp(MMcdr(form)))
  399.         FEtoo_many_argumentsF(form);
  400.     var = MMcar(form);
  401.     if (type_of(var) != t_cons) {
  402.         eval(var);
  403.         setq(var, cdr(vs_base[0]));
  404.         vs_base[0] = car(vs_base[0]);
  405.         return;
  406.     }
  407.     vs_base = vs_top;
  408.     vs_push(Spop);
  409.     vs_push(form);
  410.     stack_cons();
  411. /***/
  412.     vs_push(Cnil);
  413. /***/
  414.     if (!Spop->s.s_mflag || Spop->s.s_gfdef == OBJNULL)
  415.         FEerror("Where is POP?", 0);
  416.     funcall(Spop->s.s_gfdef);
  417.     eval(vs_base[0]);
  418. }
  419.  
  420. Fincf(form)
  421. object form;
  422. {
  423.     object var;
  424.     object one_plus(), number_plus();
  425.  
  426.     if (endp(form))
  427.         FEtoo_few_argumentsF(form);
  428.     if (!endp(MMcdr(form)) && !endp(MMcddr(form)))
  429.         FEtoo_many_argumentsF(form);
  430.     var = MMcar(form);
  431.     if (type_of(var) != t_cons) {
  432.         if (endp(MMcdr(form))) {
  433.             eval(var);
  434.             vs_base[0] = one_plus(vs_base[0]);
  435.             setq(var, vs_base[0]);
  436.             return;
  437.         }
  438.         eval(MMcadr(form));
  439.         form = vs_base[0];
  440.         eval(var);
  441.         vs_base[0] = number_plus(vs_base[0], form);
  442.         setq(var, vs_base[0]);
  443.         return;
  444.     }
  445.     vs_base = vs_top;
  446.     vs_push(Sincf);
  447.     vs_push(form);
  448.     stack_cons();
  449. /***/
  450.     vs_push(Cnil);
  451. /***/
  452.     if (!Sincf->s.s_mflag || Sincf->s.s_gfdef == OBJNULL)
  453.         FEerror("Where is INCF?", 0);
  454.     funcall(Sincf->s.s_gfdef);
  455.     eval(vs_base[0]);
  456. }
  457.  
  458. Fdecf(form)
  459. object form;
  460. {
  461.     object var;
  462.     object one_minus(), number_minus();
  463.  
  464.     if (endp(form))
  465.         FEtoo_few_argumentsF(form);
  466.     if (!endp(MMcdr(form)) && !endp(MMcddr(form)))
  467.         FEtoo_many_argumentsF(form);
  468.     var = MMcar(form);
  469.     if (type_of(var) != t_cons) {
  470.         if (endp(MMcdr(form))) {
  471.             eval(var);
  472.             vs_base[0] = one_minus(vs_base[0]);
  473.             setq(var, vs_base[0]);
  474.             return;
  475.         }
  476.         eval(MMcadr(form));
  477.         form = vs_base[0];
  478.         eval(var);
  479.         vs_base[0] = number_minus(vs_base[0], form);
  480.         setq(var, vs_base[0]);
  481.         return;
  482.     }
  483.     vs_base = vs_top;
  484.     vs_push(Sdecf);
  485.     vs_push(form);
  486.     stack_cons();
  487. /***/
  488.     vs_push(Cnil);
  489. /***/
  490.     if (!Sdecf->s.s_mflag || Sdecf->s.s_gfdef == OBJNULL)
  491.         FEerror("Where is DECF?", 0);
  492.     funcall(Sdecf->s.s_gfdef);
  493.     eval(vs_base[0]);
  494. }
  495.  
  496. clear_compiler_properties(sym)
  497. object sym;
  498. {
  499.     if (symbol_value(siVinhibit_macro_special) != Cnil)
  500.         (void)ifuncall1(siSclear_compiler_properties, sym);
  501. }
  502.  
  503. siLclear_compiler_properties()
  504. {
  505.     check_arg(1);
  506. }
  507.  
  508.  
  509. init_assignment()
  510. {
  511.     make_special_form("SETQ", Fsetq);
  512.     make_special_form("PSETQ", Fpsetq);
  513.     make_function("SET", Lset);
  514.     make_si_function("FSET", siLfset);
  515.  
  516.     make_special_form("MULTIPLE-VALUE-SETQ", Fmultiple_value_setq);
  517.  
  518.     make_function("MAKUNBOUND", Lmakunbound);
  519.     make_function("FMAKUNBOUND", Lfmakunbound);
  520.  
  521.     Ssetf = make_ordinary("SETF");
  522.  
  523.     Sget = make_ordinary("GET");
  524.     Saref = make_ordinary("AREF");
  525.     Ssvref = make_ordinary("SVREF");
  526.     Selt = make_ordinary("ELT");
  527.     Schar = make_ordinary("CHAR");
  528.     Sschar = make_ordinary("SCHAR");
  529.     Sfill_pointer = make_ordinary("FILL-POINTER");
  530.     Sgethash = make_ordinary("GETHASH");
  531.     Scar = make_ordinary("CAR");
  532.     Scdr = make_ordinary("CDR");
  533.  
  534.     make_special_form("SETF", Fsetf);
  535.  
  536.     Spush = make_ordinary("PUSH");
  537.     Spop = make_ordinary("POP");
  538.     Sincf = make_ordinary("INCF");
  539.     Sdecf = make_ordinary("DECF");
  540.  
  541.     make_special_form("PUSH", Fpush);
  542.     make_special_form("POP", Fpop);
  543.     make_special_form("INCF", Fincf);
  544.     make_special_form("DECF", Fdecf);
  545.  
  546.     siSstructure_access = make_si_ordinary("STRUCTURE-ACCESS");
  547.     enter_mark_origin(&siSstructure_access);
  548.     siSsetf_lambda = make_si_ordinary("SETF-LAMBDA");
  549.     enter_mark_origin(&siSsetf_lambda);
  550.     Svector = make_ordinary("VECTOR");
  551.     Slist = make_ordinary("LIST");
  552.  
  553.     siSclear_compiler_properties
  554.     = make_si_function("CLEAR-COMPILER-PROPERTIES",
  555.                siLclear_compiler_properties);
  556. }
  557.